; -*-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; File:         uxproc-cls.lsp
; RCS:          $Header: /disk3/npm/src/widgit/examples/lib-utils/RCS/uxproc-cls.lsp,v 1.10 1994/09/04 08:09:33 npm Exp npm $
; Description:  Unix-Subprocess-Class and methods 
;		:SET-PROCESS-FINISHED-CALLBACK, :SET-LINE-OUTPUT-CALLBACK,
;		:SET-CHAR-OUTPUT-CALLBACK, :SET-SEXP-OUTPUT-CALLBACK
;		:START-PROCESS, :KILL-PROCESS, :SIGNAL-KILL, :EXISTS_P.
; Author:       Niels P. Mayer
; Created:      Wed Aug 31 21:50:44 1994
; Modified:     Tue Sep 19 03:44:23 1995 (Niels Mayer) npm@indeed.indeed
; Language:     Lisp
; Package:      N/A
; Status:       X11r6 contrib release
;
; Copyright (C) 1994, Enterprise Integration Technologies Corp. and Niels Mayer.
; 
; Permission to use, copy, modify, distribute, and sell this software and its
; documentation for any purpose is hereby granted without fee, provided that
; the above copyright notice appear in all copies and that both that
; copyright notice and this permission notice appear in supporting
; documentation, and that the name of Enterprise Integration Technologies,
; Hewlett-Packard Company, or Niels Mayer not be used in advertising or
; publicity pertaining to distribution of the software without specific,
; written prior permission. Enterprise Integration Technologies, Hewlett-Packard
; Company, and Niels Mayer makes no representations about the suitability of
; this software for any purpose.  It is provided "as is" without express or
; implied warranty.
; 
; ENTERPRISE INTEGRATION TECHNOLOGIES, HEWLETT-PACKARD COMPANY AND NIELS MAYER
; DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED
; WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ENTERPRISE
; INTEGRATION TECHNOLOGIES, HEWLETT-PACKARD COMPANY OR NIELS MAYER BE LIABLE
; FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
; RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
; CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require "lib-utils/initialize")	;define :set-pname, etc.
(require "lib-utils/unixstuf")		;define FILE:REMOVE-PATH

(in-package "WINTERP")
(export '(UNIX-SUBPROCESS-CLASS
	  ))

(setq UNIX-SUBPROCESS-CLASS
      (send Class :new
	    '(ivar_subproc_type		;ivars
	      ivar_args
	      ivar_end_cb
	      ivar_out_cb
	      ivar_outcb_kind
	      ivar_pty
	      ivar_pid
	      ivar_icb
	      ivar_ecb
	      )
	    '()				;cvars
					;this is not a subclass
	    ))
(send UNIX-SUBPROCESS-CLASS :set-pname "UNIX-SUBPROCESS-CLASS")

;; :ISNEW initialization method -- two variants:
;;
;; (send UNIX-SUBPROCESS-CLASS :new :subshell <command-str>)
;;	--> <ux-proc>
;; (send UNIX-SUBPROCESS-CLASS :new :subproc <proc-name> <arg-1> <arg-2> ...)
;;	--> <ux-proc>
;;
(send UNIX-SUBPROCESS-CLASS :answer :ISNEW
      '(k-subproc-type proc-str &rest args)
      '(
	(case k-subproc-type
	      (:subproc
	       (setq ivar_args       (cons proc-str
					   (cons (file:remove-path proc-str)
						 args)) ;setup args for exp_spawn
		     ivar_subproc_type	:subproc
		     ivar_end_cb	NIL
		     ivar_out_cb	NIL
		     ivar_outcb_kind	NIL
		     ivar_pid		NIL
		     ivar_pty		NIL
		     ivar_icb		NIL
		     ivar_ecb		NIL)
	       )
	      (:subshell
	       (if (not (and (stringp proc-str) (null args)))
		   (error "invalid arguments" (cons proc-str args)))
	       (setq ivar_args		(list proc-str) ;setup args for exp_popen
		     ivar_subproc_type	:subshell
		     ivar_end_cb	NIL
		     ivar_out_cb	NIL
		     ivar_outcb_kind	NIL
		     ivar_pid		NIL
		     ivar_pty		NIL
		     ivar_icb		NIL
		     ivar_ecb		NIL)
	       )
	      (t
	       (error "invalid subprocess type keyword, expected either :subproc or :subshell"
		      k_subproc_type)
	       ))
	))

;; :SET-PROCESS-FINISHED-CALLBACK -- set closure that gets
;; called when the process terminates.
;;
;; (send <ux-proc> :set-process-finished-callback
;;	 #'(lambda (exit-status-dotted-pair) ...))
;;   where exit-status-dotted-pair == (pid . exit-status) on success;
;;   and   exit-status-dotted-pair == (-1  . sys_errlist[errno]) on failure.
;;
(send UNIX-SUBPROCESS-CLASS :answer :SET-PROCESS-FINISHED-CALLBACK
      '(closure)
      '(
	(setq ivar_end_cb closure)

	;; if an old error callback was previously set, set a new one.
	;; but ... if this method called prior to :START-PROCESS, then
	;; don't. Note that :START-PROCESS calls :SET-PROCESS-FINISHED-CALLBACK
	;; once the process has been created.
	(if ivar_pty
	    (progn
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_ecb))
		       (input_active_p ivar_ecb))
		  (xt_remove_input ivar_ecb))

	      (if ivar_end_cb
		  ;; user wants his/her own code called in exception callback
		  (setq ivar_ecb
			(xt_add_input
			 ivar_pty :except
			 `(
;;; (format t "BEGIN CUSTOM EXCEPTION-CB ...")
			   (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
				    (input_active_p ivar_icb))
			       (xt_remove_input ivar_icb))
			   (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_ecb))
				    (input_active_p ivar_ecb))
			       (xt_remove_input ivar_ecb))
			   (close ivar_pty)

			   (setq ivar_pid NIL
				 ivar_pty NIL
				 ivar_icb NIL
				 ivar_ecb NIL)
;;; (format t " CALLING USER-CODE ...")
 			   ;; Call the closure here...
 			   (funcall ,ivar_end_cb
 				    (exp_wait))
;;; (format t " EXCEPTION-CB DONE!\n\n")
			   )))

		;; default exception callback
		(setq ivar_ecb
		      (xt_add_input
		       ivar_pty :except
		       '(
;;; (format t "BEGIN DEFAULT EXCEPTION-CB ...")
			 (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
				  (input_active_p ivar_icb))
			     (xt_remove_input ivar_icb))
			 (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_ecb))
				  (input_active_p ivar_ecb))
			     (xt_remove_input ivar_ecb))
			 (close ivar_pty)
			 (setq ivar_pid NIL
			       ivar_pty NIL
			       ivar_icb NIL
			       ivar_ecb NIL)
			 (exp_wait)
;;; (format t " DONE!\n\n")
			 )))
		))
	  )
	))

;;
;; :SET-LINE-OUTPUT-CALLBACK -- set closure that gets
;; called when the process terminates. 
;;
;; (send <ux-proc> :set-line-output-callback
;;	 #'(lambda (FDINPUTCB_STRING) ))
;;
(send UNIX-SUBPROCESS-CLASS :answer :SET-LINE-OUTPUT-CALLBACK
      '(closure)
      '(
	(setq ivar_outcb_kind :READ_LINE_TO_STRING)
	(setq ivar_out_cb closure)

	;; if an old input callback was previously set, set a new one.
	;; but ... if this method called prior to :START-PROCESS, then
	;; don't. Note that :START-PROCESS may call
	;; :SET-LINE-OUTPUT-CALLBACK once the process has been created.
	(if ivar_pty
	    (progn
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
		       (input_active_p ivar_icb))
		  (xt_remove_input ivar_icb))
	      (setq ivar_icb
		    (xt_add_input
		     ivar_pty ivar_outcb_kind
		     `(
		       (funcall ,ivar_out_cb FDINPUTCB_STRING)
		       )))
	      )
	  )
	))

;;
;; :SET-CHAR-OUTPUT-CALLBACK -- set closure that gets
;; called whenever there are characters available for
;; reading. Must use nonblocking reads, e.g. read-char.
;;
;; (send <ux-proc> :set-char-output-callback
;;	 #'(lambda (FDINPUTCB_FILE) ))
;;
(send UNIX-SUBPROCESS-CLASS :answer :SET-CHAR-OUTPUT-CALLBACK
      '(closure)
      '(
	(setq ivar_outcb_kind :READ)
	(setq ivar_out_cb closure)

	;; if an old input callback was previously set, set a new one.
	;; but ... if this method called prior to :START-PROCESS, then
	;; don't. Note that :START-PROCESS may call
	;; :SET-CHAR-OUTPUT-CALLBACK once the process has been created.
	(if ivar_pty
	    (progn
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
		       (input_active_p ivar_icb))
		  (xt_remove_input ivar_icb))
	      (setq ivar_icb
		    (xt_add_input
		     ivar_pty ivar_outcb_kind
		     `(
		       (funcall ,ivar_out_cb FDINPUTCB_FILE)
		       )))
	      )
	  )
	))

;; 
;; (send <ux-proc> :set-sexp-output-callback 
;;	 #'(lambda (FDINPUTCB_USTREAM) ))
;;
(send UNIX-SUBPROCESS-CLASS :answer :SET-SEXP-OUTPUT-CALLBACK
      '(closure)
      '(
	(setq ivar_outcb_kind :READ_SEXP_TO_USTREAM)
	(setq ivar_out_cb closure)

	;; if an old input callback was previously set, set a new one.
	;; but ... if this method called prior to :START-PROCESS, then
	;; don't. Note that :START-PROCESS may call
	;; :SET-SEXP-OUTPUT-CALLBACK once the process has been created.
	(if ivar_pty
	    (progn
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
		       (input_active_p ivar_icb))
		  (xt_remove_input ivar_icb))
	      (setq ivar_icb
		    (xt_add_input
		     ivar_pty ivar_outcb_kind
		     `(
		       (funcall ,ivar_out_cb FDINPUTCB_USTREAM)
		       )))
	      )
	  )
	))

;;
;; :CLEAR-OUTPUT-CALLBACK -- clear any previously set output callback
;;
;; (send <ux-proc> :clear-output-callback)
;;
(send UNIX-SUBPROCESS-CLASS :answer :CLEAR-OUTPUT-CALLBACK
      '()
      '(
	(if ivar_pty
	    (progn
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
		       (input_active_p ivar_icb))
		  (xt_remove_input ivar_icb))
	      ))
	))

;;
;; (send <ux-proc> :START-PROCESS)
;;
;; call this method to actually start the process. Should
;; probably :SET-PROCESS-FINISHED-CALLBACK and one of the
;; three output callback types via:
;;	:SET-SEXP-OUTPUT-CALLBACK
;;	:SET-CHAR-OUTPUT-CALLBACK or
;;	:SET-LINE-OUTPUT-CALLBACK
;;
(send UNIX-SUBPROCESS-CLASS :answer :START-PROCESS
      '()
      '(
	(case ivar_subproc_type
	      (:subproc
	       (setq ivar_pty
		     (apply #'exp_spawn ivar_args))
	       )
	      (:subshell
	       (setq ivar_pty
		     (apply #'exp_popen ivar_args))
	       ))
	(setq ivar_pid
	      (exp_get_pid)
	      )

	(if (eq 'CLOSURE (type-of ivar_out_cb))
	    (case ivar_outcb_kind
		  (:READ_LINE_TO_STRING
		   (send self :set-line-output-callback ivar_out_cb)
		   )
		  (:READ_SEXP_TO_USTREAM
		   (send self :set-sexp-output-callback ivar_out_cb)
		   )
		  (:READ
		   (send self :set-char-output-callback ivar_out_cb)
		   ))
	  ;; else if ivar_out_cb is not a closure (e.g. unititialized NIL),
	  ;; then don't bother setting an output callback.
	  )

	(if (eq 'CLOSURE (type-of ivar_end_cb))
	    (send self :set-process-finished-callback ivar_end_cb)	
	  (send self :set-process-finished-callback NIL) ;set default process finished callproc
	  )
	))

;;
;; (send <ux-proc> :KILL-PROCESS)
;; 
;; using this method is deprecated, since it will bypass call to callback
;; set by :SET-PROCESS-FINISHED-CALLBACK. This call can be put
;; inside a widget's :XMN_DESTROY_CALLBACK, so as to ensure
;; destruction of process is "synchronous". For example, it may be
;; inappropriate to call the callback set by
;; :SET-PROCESS-FINISHED-CALLBACK after the widgetry associated with
;; the process no longer exists.
;;
(send UNIX-SUBPROCESS-CLASS :answer :KILL-PROCESS
      '()
      '(
	(if ivar_pid
	    (progn
	      (exp_kill "KILL" ivar_pid)
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_icb))
		       (input_active_p ivar_icb))
		  (xt_remove_input ivar_icb))
	      (if (and (eq 'FDINPUTCB_OBJ (type-of ivar_ecb))
		       (input_active_p ivar_ecb))
		  (xt_remove_input ivar_ecb))
	      (close ivar_pty)
	      (setq ivar_pid	NIL
		    ivar_icb	NIL
		    ivar_ecb	NIL
		    ivar_pty	NIL)
	      (exp_wait)
	      T
	      )
	  NIL
	  )
	))

;;
;; (send <ux-proc> :SIGNAL-KILL <kill-sig>)
;;
;; Send the subprocess a kill signal. Note that the process is known to
;; have terminated only when the callback set in :SET-PROCESS-FINISHED-CALLBACK
;; is called...
;;
(send UNIX-SUBPROCESS-CLASS :answer :SIGNAL-KILL
      '(kill-sig)
      '(
	(if ivar_pid
	    (exp_kill kill-sig ivar_pid)
	  (error "can't signal process -- process doesn't exist"
		 ivar_args
		 )
	  )
	))

;;
;; (send <ux-proc> :EXISTS_P)
;;
;; Boolean -- check if the subprocess associated with the object is running.
;;
(send UNIX-SUBPROCESS-CLASS :answer :EXISTS_P
      '()
      '(
	(streamp ivar_pty)
	))

;;
;; (send <ux-proc> :FORMAT <format-string> <format-arg-1> ... <format-arg-n>)
;;
;; Use the 'format' command to send data to the subprocess. See
;; 'format' for a descruption of the formatting commands available
;; for <format-str>.
;;
(send UNIX-SUBPROCESS-CLASS :answer :FORMAT
      '(format-str &rest args)
      '(
	(if (streamp ivar_pty)
	    (apply #'format ivar_pty format-str args)
	  (error "can't send to process -- process doesn't exist"
		 ivar_args))
	))

;;
;; (send <ux-proc> :GET-PID)
;;	--> returns process ID as a FIXNUM, or NIL if
;;	    process doesn't exist.
;;
(send UNIX-SUBPROCESS-CLASS :answer :GET-PID
      '()
      '(ivar_pid))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide "lib-utils/uxproc-cls")
